home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / demos / sortdemo.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-23  |  19KB  |  617 lines

  1. PROGRAM SortDemo;
  2.  
  3. { Graphical demonstration of sorting algorithms (W. N~ker, 02/96) }
  4. { based on "Sortieren" of Purity #48 }
  5.  
  6. {
  7.     Translated to PCQ from Kick(Maxon) Pascal.
  8.     Updated the source to 2.0+.
  9.     Now uses GadTools for menus.
  10.     Added CloseWindowSafely.
  11.     Cleaned up the menuhandling.
  12.     Added LockWinSize and RestoreWin, now the
  13.     window will be locked on showtime.
  14.  
  15.     The German text was translated to English
  16.     by Andreas Neumann, thanks Andreas.
  17.     Jun 03 1998.
  18.  
  19.     Translated to FPC Pascal.
  20.     Removed CloseWindowSafely, have do add
  21.     that procedure to Intuition.
  22.     Fixed a bug, when you halt the show the
  23.     window stayed locked.
  24.     Aug 23 1998.
  25.  
  26.     nils.sjoholm@mailbox.swipnet.se
  27.  
  28.     One last remark, the heapsort can't be stoped
  29.     so you have to wait until it's finished.
  30. }
  31.  
  32. uses Exec, Intuition, Graphics, Utility, GadTools;
  33.  
  34. {$I tagutils.inc}
  35.  
  36. CONST version : PChar = '$VER: SortDemo 1.3  (23-Aug-98)';
  37.  
  38.       nmax=2000;
  39.  
  40.       MinWinX = 80;
  41.       MinWiny = 80;
  42.  
  43.       w         : pWindow  = Nil;
  44.       s         : pScreen  = Nil;
  45.       MenuStrip : pMenu    = Nil;
  46.       vi        : Pointer  = Nil;
  47.       ltrue     : longint  = -1;
  48.  
  49.       modenames : Array[0..7] of string[10] = (
  50.                                 'Heapsort',
  51.                                 'Shellsort',
  52.                                 'Pick out',
  53.                                 'Insert',
  54.                                 'Shakersort',
  55.                                 'Bubblesort',
  56.                                 'Quicksort',
  57.                                 'Mergesort');
  58.  
  59.       { The easiest way to use gadtoolsmenus in FPC is
  60.         to have them as const types. No need to cast
  61.         strings to PChar. That we have to use recordmembers
  62.         name is a pain.
  63.       }
  64.  
  65.       nm : array[0..21] of tNewMenu = (
  66.       (nm_Type: NM_TITLE; nm_Label: 'Demo';        nm_CommKey: NIL; nm_Flags: 0; nm_MutualExclude: 0; nm_UserData: NIL),
  67.       (nm_Type: NM_ITEM;  nm_Label: 'Start';       nm_CommKey: 'S'; nm_Flags: 0; nm_MutualExclude: 0; nm_UserData: NIL),
  68.       (nm_Type: NM_ITEM;  nm_Label: 'Stop';        nm_CommKey: 'H'; nm_Flags: 0; nm_MutualExclude: 0; nm_UserData: NIL),
  69.  
  70.       { this will be a barlabel, have to set this one later }
  71.       (nm_Type: NM_ITEM;  nm_Label: NIL;           nm_CommKey: NIL; nm_Flags: 0; nm_MutualExclude: 0; nm_UserData: NIL),
  72.  
  73.       (nm_Type: NM_ITEM;  nm_Label: 'Quit';        nm_CommKey: 'Q'; nm_Flags: 0; nm_MutualExclude: 0; nm_UserData: NIL),
  74.       (nm_Type: NM_TITLE; nm_Label: 'Algorithm';   nm_CommKey: NIL; nm_Flags: 0; nm_MutualExclude: 0; nm_UserData: NIL),
  75.       (nm_Type: NM_ITEM;  nm_Label: 'HeapSort';    nm_CommKey: '1'; nm_Flags: CHECKIT+CHECKED+MENUTOGGLE; nm_MutualExclude: 254; nm_UserData: NIL),
  76.       (nm_Type: NM_ITEM;  nm_Label: 'ShellSort';   nm_CommKey: '2'; nm_Flags: CHECKIT+MENUTOGGLE; nm_MutualExclude: 253; nm_UserData: NIL),
  77.       (nm_Type: NM_ITEM;  nm_Label: 'Pick out';    nm_CommKey: '3'; nm_Flags: CHECKIT+MENUTOGGLE; nm_MutualExclude: 251; nm_UserData: NIL),
  78.       (nm_Type: NM_ITEM;  nm_Label: 'Insert';      nm_CommKey: '4'; nm_Flags: CHECKIT+MENUTOGGLE; nm_MutualExclude: 247; nm_UserData: NIL),
  79.       (nm_Type: NM_ITEM;  nm_Label: 'ShakerSort';  nm_CommKey: '5'; nm_Flags: CHECKIT+MENUTOGGLE; nm_MutualExclude: 239; nm_UserData: NIL),
  80.       (nm_Type: NM_ITEM;  nm_Label: 'BubbleSort';  nm_CommKey: '6'; nm_Flags: CHECKIT+MENUTOGGLE; nm_MutualExclude: 223; nm_UserData: NIL),
  81.       (nm_Type: NM_ITEM;  nm_Label: 'QuickSort';   nm_CommKey: '7'; nm_Flags: CHECKIT+MENUTOGGLE; nm_MutualExclude: 191; nm_UserData: NIL),
  82.       (nm_Type: NM_ITEM;  nm_Label: 'MergeSort';   nm_CommKey: '8'; nm_Flags: CHECKIT+MENUTOGGLE; nm_MutualExclude: 127; nm_UserData: NIL),
  83.       (nm_Type: NM_TITLE; nm_Label: 'Preferences'; nm_CommKey: NIL; nm_Flags: 0; nm_MutualExclude: 0; nm_UserData: NIL),
  84.       (nm_Type: NM_ITEM;  nm_Label: 'Data';        nm_CommKey: NIL; nm_Flags: 0; nm_MutualExclude: 0; nm_UserData: NIL),
  85.       (nm_Type: NM_SUB;   nm_Label: 'Random';      nm_CommKey: 'R'; nm_Flags: CHECKIT+CHECKED+MENUTOGGLE; nm_MutualExclude: 2; nm_UserData: NIL),
  86.       (nm_Type: NM_SUB;   nm_Label: 'Malicious';   nm_CommKey: 'M'; nm_Flags: CHECKIT+MENUTOGGLE; nm_MutualExclude: 1; nm_UserData: NIL),
  87.       (nm_Type: NM_ITEM;  nm_Label: 'Diagram';     nm_CommKey: NIL; nm_Flags: 0; nm_MutualExclude: 0; nm_UserData: NIL),
  88.       (nm_Type: NM_SUB;   nm_Label: 'Needles';     nm_CommKey: 'N'; nm_Flags: CHECKIT+CHECKED+MENUTOGGLE; nm_MutualExclude: 2; nm_UserData: NIL),
  89.       (nm_Type: NM_SUB;   nm_Label: 'Dots';        nm_CommKey: 'D'; nm_Flags: CHECKIT+MENUTOGGLE; nm_MutualExclude: 1; nm_UserData: NIL),
  90.       (nm_Type: NM_END;   nm_Label: NIL;           nm_CommKey: NIL; nm_Flags: 0;nm_MutualExclude:0;nm_UserData:NIL));
  91.  
  92.  
  93. VAR sort: ARRAY[1..nmax] OF Real;
  94.     sort2: ARRAY[1..nmax] OF Real;  { for dumb Mergesort %-( }
  95.     num,range,modus : Integer;
  96.     rndom,needles   : Boolean;
  97.     Rast            : pRastPort;
  98.     QuitStopDie     : Boolean;
  99.     Msg             : pMessage;
  100.     wintitle        : string[80];
  101.     scrtitle        : string[80];
  102.     tags            : array[1..18] of tTagItem;
  103.  
  104. Procedure CleanUp(s : string; err : Integer);
  105. begin
  106.     if MenuStrip <> nil then begin
  107.        ClearMenuStrip(w);
  108.        FreeMenus(MenuStrip);
  109.     end;
  110.     if vi <> nil then FreeVisualInfo(vi);
  111.     if w <> nil then CloseWindow(w);
  112.     if GfxBase <> nil then CloseLibrary(GfxBase);
  113.     if GadToolsBase <> nil then CloseLibrary(GadToolsBase);
  114.     if s <> '' then writeln(s);
  115.     Halt(err);
  116. end;
  117.  
  118. Procedure RestoreWin;
  119. var
  120.    dummy : Boolean;
  121. begin
  122.    dummy := WindowLimits(w,MinWinX,MinWinY,-1,-1);
  123. end;
  124.  
  125. Procedure LockWinSize(x,y,x2,y2 : Integer);
  126. var
  127.    dummy : Boolean;
  128. begin
  129.    dummy := WindowLimits(w,x,y,x2,y2);
  130. end;
  131.  
  132. FUNCTION cancel: Boolean;
  133. { checked while sorting }
  134. VAR m,i,s: Integer;
  135.     result : boolean;
  136.     IM : pIntuiMessage;
  137. BEGIN
  138.   result := False;
  139.   IM := pIntuiMessage(GetMsg(w^.UserPort));
  140.   IF IM<>Nil THEN BEGIN
  141.     IF IM^.IClass=IDCMP_CLOSEWINDOW THEN
  142.       result := True;   { Close-Gadget }
  143.     IF IM^.IClass=IDCMP_MENUPICK THEN BEGIN
  144.       m := IM^.Code AND $1F;
  145.       i := (IM^.Code SHR 5) AND $3F;
  146.       s := (IM^.Code SHR 11) AND $1F;
  147.       IF (m=0) AND (i=1) THEN  result := True;  { Menu item "Stop" }
  148.     END;
  149.     ReplyMsg(pMessage(Msg));
  150.   END;
  151.   cancel := result;
  152. END;
  153.  
  154.  
  155. PROCEDURE showstack(size: Integer);
  156. { little diagram showing the depth of Quicksort's recursion :-) }
  157. BEGIN
  158.   SetAPen(Rast,2); IF size>0 THEN RectFill(Rast,0,0,3,size-1);
  159.   SetAPen(Rast,0); RectFill(Rast,0,size,3,size);
  160. END;
  161.  
  162.  
  163. PROCEDURE setpixel(i: Integer);
  164. BEGIN
  165.   SetAPen(Rast,1);
  166.   IF needles THEN BEGIN
  167.     Move(Rast,i,range); Draw(Rast,i,Round((1-sort[i])*range));
  168.   END ELSE
  169.     IF WritePixel(Rast,i,Round((1-sort[i])*range))=0 THEN;
  170. END;
  171.  
  172. PROCEDURE clearpixel(i: Integer);
  173. BEGIN
  174.   SetAPen(Rast,0);
  175.   IF needles THEN BEGIN
  176.     Move(Rast,i,range); Draw(Rast,i,Round((1-sort[i])*range));
  177.   END ELSE
  178.     IF WritePixel(Rast,i,Round((1-sort[i])*range))=0 THEN;
  179. END;
  180.  
  181. procedure Exchange(var first,second : real);
  182. var
  183.   temp : real;
  184. begin
  185.   temp := first;
  186.   first := second;
  187.   second := temp;
  188. end;
  189.  
  190. PROCEDURE swapit(i,j: integer);
  191. BEGIN
  192.   clearpixel(i); clearpixel(j);
  193.   Exchange(sort[i],sort[j]);
  194.   setpixel(i); setpixel(j);
  195. END;
  196.  
  197. FUNCTION descending(i,j: Integer): Boolean;
  198. BEGIN
  199.   descending := sort[i]>sort[j];
  200. END;
  201.  
  202. Function IntToStr (I : Longint) : String;
  203.  
  204.      Var S : String;
  205.  
  206.      begin
  207.       Str (I,S);
  208.       IntToStr:=S;
  209.      end;
  210.  
  211.  
  212. PROCEDURE settitles(time: Longint);
  213. VAR
  214.   s : string[80];
  215. BEGIN
  216.   s := modenames[modus];
  217.   IF time=0 THEN
  218.     wintitle := s + ' running ...'
  219.   ELSE IF time < 0 then
  220.     wintitle := '<- ' + IntToStr(num) + ' Data ->'
  221.   ELSE
  222.     wintitle := IntToStr(time) + ' Seconds';
  223.   scrtitle := strpas(@version[6]) + ' - ' + s;
  224.   wintitle := wintitle + #0;
  225.   scrtitle := scrtitle + #0;
  226.   SetWindowTitles(w,@wintitle[1],@scrtitle[1]);
  227. END;
  228.  
  229. PROCEDURE refresh;
  230. { react on new size of window/init data }
  231. VAR i: Integer;
  232. BEGIN
  233.   num := w^.GZZWidth; IF num>nmax THEN num := nmax;
  234.   range := w^.GZZHeight;
  235.   settitles(-1);
  236.   SetRast(Rast,0);    { clear screen }
  237.   FOR i := 1 TO num DO BEGIN
  238.     IF rndom THEN sort[i] := Random  { produces 0..1 }
  239.       ELSE sort[i] := (num-i)/num;
  240.     setpixel(i);
  241.   END;
  242. END;
  243.  
  244. { *#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#* }
  245. { *#*#*#*#*#*#*#*#*#*#*# The sorting algorithms! #*#*#*#*#*#*#*#*#*#*#*#* }
  246. { *#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#*#* }
  247.  
  248. PROCEDURE bubblesort;
  249. { like the head of a beer, reaaal slow and easy-going }
  250. VAR i,j,max: Integer;
  251. BEGIN
  252.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  253.   max := num;
  254.   REPEAT
  255.     j := 1;
  256.     FOR i := 1 TO max-1 DO
  257.       IF descending(i,i+1) THEN BEGIN
  258.         swapit(i,i+1); j := i;
  259.       END;
  260.     max := j;
  261.   UNTIL (max=1) OR cancel;
  262.   RestoreWin;
  263. END;
  264.  
  265. PROCEDURE shakersort;
  266. { interesting variant, but bubblesort still remains hopelessness }
  267. { (because it only compares and swaps immediate adjacent units)  }
  268. VAR i,j,min,max: Integer;
  269. BEGIN
  270.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  271.   min := 1;
  272.   max := num;
  273.   REPEAT
  274.     j := min;
  275.     FOR i := min TO max-1 DO
  276.       IF descending(i,i+1) THEN BEGIN
  277.         swapit(i,i+1); j := i;
  278.       END;
  279.     max := j;
  280.     j := max;
  281.     FOR i := max DOWNTO min+1 DO
  282.       IF descending(i-1,i) THEN BEGIN
  283.         swapit(i,i-1); j := i;
  284.       END;
  285.     min := j;
  286.   UNTIL (max=min) OR cancel;
  287.   RestoreWin;
  288. END;
  289.  
  290. PROCEDURE e_sort;
  291. { Insert: a pretty human strategy }
  292. VAR i,j: Integer;
  293. BEGIN
  294.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  295.   FOR i := 2 TO num DO BEGIN
  296.     j := i;
  297.     WHILE j>1 DO
  298.       IF descending(j-1,j) THEN BEGIN
  299.         swapit(j-1,j); Dec(j);
  300.       END ELSE
  301.         j := 1;
  302.     IF cancel THEN begin
  303.         RestoreWin;
  304.         Exit;
  305.     end;
  306.   END;
  307.   RestoreWin;
  308. END;
  309.  
  310. PROCEDURE a_sort;
  311. { Pick out: Preparation is one half of a life }
  312. { Take a look at the ridiculous low percentage of successful comparisions:  }
  313. { Although there are only n swaps, there are n^2/2 comparisions!            }
  314. { Both is a record, one in a good sense, the other one in a bad sense.      }
  315.  
  316. VAR i,j,minpos: Integer;
  317.     min: Real;
  318. BEGIN
  319.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  320.   FOR i := 1 TO num-1 DO BEGIN
  321.     minpos := i; min := sort[i];
  322.     FOR j := i+1 TO num DO
  323.       IF descending(minpos,j) THEN
  324.         minpos := j;
  325.     IF minpos<>i THEN swapit(i,minpos);
  326.     IF cancel THEN begin
  327.         RestoreWin;
  328.         Exit;
  329.     end;
  330.   END;
  331.   RestoreWin;
  332. END;
  333.  
  334. PROCEDURE shellsort;
  335. { brilliant extension of E-Sort, stunning improvement of efficience }
  336. VAR i,j,gap: Integer;
  337. BEGIN
  338.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  339.   gap := num DIV 2;
  340.   REPEAT
  341.     FOR i := 1+gap TO num DO BEGIN
  342.       j := i;
  343.       WHILE j>gap DO
  344.         IF descending(j-gap,j) THEN BEGIN
  345.           swapit(j,j-gap); j := j-gap;
  346.         END ELSE
  347.           j := 1;
  348.       IF cancel THEN begin
  349.           RestoreWin;
  350.           Exit;
  351.       end;
  352.     END;
  353.     gap := gap DIV 2;
  354.   UNTIL gap=0;
  355.   RestoreWin;
  356. END;
  357.  
  358. PROCEDURE seepaway(i,max: Integer);
  359. { belongs to heapsort }
  360. VAR j: Integer;
  361. BEGIN
  362.   j := 2*i;
  363.   WHILE j<=max DO BEGIN
  364.     IF j<max THEN IF descending(j+1,j) THEN
  365.       Inc(j);
  366.     IF descending(j,i) THEN BEGIN
  367.       swapit(j,i);
  368.       i := j; j := 2*i;
  369.     END ELSE
  370.       j := max+1; { cancels }
  371.   END;
  372. END;
  373.  
  374. PROCEDURE heapsort;
  375. { this genius rules over the chaos: it's the best algorithm, I know about    }
  376. { The only disadvantage compared with shellsort: it's not easy to understand }
  377. { and impossible to know it by heart. }
  378. VAR i,j: Integer;
  379. BEGIN
  380.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  381.   i := num DIV 2 + 1;
  382.   j := num;
  383.   WHILE i>1 DO BEGIN
  384.     Dec(i); seepaway(i,j);
  385.   END;
  386.   WHILE j>1 DO BEGIN
  387.     swapit(i,j);
  388.     Dec(j); seepaway(i,j);
  389.   END;
  390.   RestoreWin;
  391. END;
  392.  
  393. PROCEDURE quicksort;
  394. { "divide and rule": a classic, but recursive  >>-( }
  395. { In this demonstration it is faster than heapsort, but does considerable }
  396. { more unsuccessful comparisions. }
  397. VAR stack: ARRAY[1..100] OF RECORD li,re: Integer; END;
  398.     sp,l,r,m,i,j: Integer;
  399. BEGIN
  400.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  401.   sp := 1; stack[1].li := 1; stack[1].re := num;
  402.   REPEAT
  403.     l := stack[sp].li; r := stack[sp].re; Dec(sp);
  404.     showstack(sp);
  405.     m := (l+r) DIV 2;
  406.     i := l; j := r;
  407.     REPEAT
  408.       WHILE descending(m,i) DO Inc(i);
  409.       WHILE descending(j,m) DO Dec(j);
  410.       IF j>i THEN swapit(i,j);
  411.       IF m=i THEN m := j ELSE IF m=j THEN m := i; { ahem ... }
  412.       { This "Following" of the reference data is only required because  }
  413.       { I stubborn call the comparision function, and this one only gets }
  414.       { indices on the values which have to be compared. }
  415.     UNTIL i>=j;
  416.     IF i>l THEN BEGIN
  417.       Inc(sp); stack[sp].li := l; stack[sp].re := i; END;
  418.     IF i+1<r THEN BEGIN
  419.       Inc(sp); stack[sp].li := i+1; stack[sp].re := r; END;
  420.   UNTIL (sp=0) OR cancel;
  421.   RestoreWin;
  422. END;
  423.  
  424. PROCEDURE mergesort;
  425. { *the* algorithm for lists with pointers on it, for arrays rather }
  426. { inacceptable. The non.recursive implementation came out pretty more }
  427. { complicated than the one for quicksort, as quicksort first does }
  428. { something and then recurses; with mergesort it is the other way round. }
  429. VAR stack: ARRAY[1..100] OF RECORD li,re,mi: Integer; END;
  430.     sp,l,r,i,j,k,m: Integer;
  431. BEGIN
  432.   LockWinSize(w^.Width,w^.Height,w^.Width,w^.Height);
  433.   sp := 1; stack[1].li := 1; stack[1].re := num; stack[1].mi := 0;
  434.   REPEAT
  435.     l := stack[sp].li; r := stack[sp].re; m := stack[sp].mi; Dec(sp);
  436.     showstack(sp);
  437.     IF m>0 THEN BEGIN { put two halfs together }
  438.       { Unfortunately it is only possible in an efficient way by using }
  439.       { extra memory; mergesort really is something for lists with }
  440.       { pointers originally ... }
  441.       FOR i := m DOWNTO l do sort2[i] := sort[i];  i := l;
  442.       FOR j := m+1 TO r DO sort2[r+m+1-j] := sort[j];  j := r;
  443.       FOR k := l TO r DO BEGIN
  444.         clearpixel(k);
  445.         IF sort2[i]<sort2[j] THEN BEGIN
  446.           sort[k] := sort2[i]; Inc(i);
  447.         END ELSE BEGIN
  448.           sort[k] := sort2[j]; Dec(j);
  449.         END;
  450.         setpixel(k);
  451.       END;
  452.     END ELSE IF l<r THEN BEGIN
  453.       { create two halfs and the order to put them together }
  454.       m := (l+r) DIV 2;
  455.       Inc(sp); stack[sp].li := l; stack[sp].mi := m; stack[sp].re := r;
  456.       Inc(sp); stack[sp].li := m+1; stack[sp].mi := 0; stack[sp].re := r;
  457.       Inc(sp); stack[sp].li := l; stack[sp].mi := 0; stack[sp].re := m;
  458.     END;
  459.   UNTIL (sp=0) OR cancel;
  460.   RestoreWin;
  461. END;
  462.  
  463.  
  464. Procedure OpenEverything;
  465. begin
  466.     GadToolsBase := OpenLibrary(PChar('gadtools.library'#0),37);
  467.     if GadToolsBase = nil then CleanUp('Can''t open gadtools.library',20);
  468.     GfxBase := OpenLibrary(GRAPHICSNAME,37);
  469.     if GfxBase = nil then CleanUp('Can''t open graphics.library',20);
  470.  
  471.     s := LockPubScreen(nil);
  472.     if s = nil then CleanUp('Could not lock pubscreen',10);
  473.  
  474.     vi := GetVisualInfoA(s, NIL);
  475.     if vi = nil then CleanUp('No visual info',10);
  476.  
  477.                 tags[1] := TagItem(WA_IDCMP,         IDCMP_CLOSEWINDOW or IDCMP_MENUPICK or IDCMP_NEWSIZE);
  478.                 tags[2] := TagItem(WA_Left,          0);
  479.                 tags[3] := TagItem(WA_Top,           s^.BarHeight+1);
  480.                 tags[4] := TagItem(WA_Width,         224);
  481.                 tags[5] := TagItem(WA_Height,        s^.Height-(s^.BarHeight-1));
  482.                 tags[6] := TagItem(WA_MinWidth,      MinWinX);
  483.                 tags[7] := TagItem(WA_MinHeight,     MinWinY);
  484.                 tags[8] := TagItem(WA_MaxWidth,      -1);
  485.                 tags[9] := TagItem(WA_MaxHeight,     -1);
  486.                 tags[10] := TagItem(WA_DepthGadget,   ltrue);
  487.                 tags[11] := TagItem(WA_DragBar,       ltrue);
  488.                 tags[12] := TagItem(WA_CloseGadget,   ltrue);
  489.                 tags[13] := TagItem(WA_SizeGadget,    ltrue);
  490.                 tags[14] := TagItem(WA_Activate,      ltrue);
  491.                 tags[15] := TagItem(WA_SizeBRight,    ltrue);
  492.                 tags[16] := TagItem(WA_GimmeZeroZero, ltrue);
  493.                 tags[17] := TagItem(WA_PubScreen,     longint(s));
  494.                 tags[18].ti_Tag := TAG_END;
  495.     w := OpenWindowTagList(NIL, @tags[1]);
  496.     IF w=NIL THEN CleanUp('Could not open window',20);
  497.  
  498.     Rast := w^.RPort;
  499.  
  500.     { Here we set the barlabel }
  501.     nm[3].nm_Label := PChar(NM_BARLABEL);
  502.  
  503.     if pExecBase(_ExecBase)^.LibNode.Lib_Version >= 39 then begin
  504.         tags[1] := TagItem(GTMN_FrontPen, 1);
  505.         tags[2].ti_Tag := TAG_END;
  506.         MenuStrip := CreateMenusA(@nm,@tags[1]);
  507.     end else MenuStrip := CreateMenusA(@nm,NIL);
  508.  
  509.     if MenuStrip = nil then CleanUp('Could not open Menus',10);
  510.     if LayoutMenusA(MenuStrip,vi,NIL)=false then
  511.         CleanUp('Could not layout Menus',10);
  512.  
  513.     if SetMenuStrip(w, MenuStrip) = false then
  514.         CleanUp('Could not set the Menus',10);
  515.  
  516. end;
  517.  
  518. PROCEDURE ProcessIDCMP;
  519. VAR
  520.     IMessage    : tIntuiMessage;
  521.     IPtr    : pIntuiMessage;
  522.  
  523.     Procedure ProcessMenu;
  524.     var
  525.     MenuNumber  : Integer;
  526.     ItemNumber  : Integer;
  527.     SubItemNumber   : Integer;
  528.     t0,t1,l         : Longint;
  529.  
  530.     begin
  531.     if IMessage.Code = MENUNULL then
  532.         Exit;
  533.  
  534.     MenuNumber := MenuNum(IMessage.Code);
  535.     ItemNumber := ItemNum(IMessage.Code);
  536.     SubItemNumber := SubNum(IMessage.Code);
  537.  
  538.     case MenuNumber of
  539.       0 : begin
  540.           case ItemNumber of
  541.              0 : begin
  542.                    refresh;
  543.                    settitles(0);
  544.                    CurrentTime(t0,l);
  545.                    CASE modus OF
  546.                      0: heapsort;
  547.                      1: shellsort;
  548.                      2: a_sort;
  549.                      3: e_sort;
  550.                      4: shakersort;
  551.                      5: bubblesort;
  552.                      6: quicksort;
  553.                      7: mergesort;
  554.                    END;
  555.                    CurrentTime(t1,l);
  556.                    settitles(t1-t0);
  557.                  end;
  558.              3 : QuitStopDie := True;
  559.           end;
  560.           end;
  561.       1 : begin
  562.           case ItemNumber of
  563.               0..7 : modus := ItemNumber;
  564.           end;
  565.           settitles(-1);
  566.           end;
  567.       2 : begin
  568.           case ItemNumber of
  569.              0 : begin
  570.                  case SubItemNumber of
  571.                     0 : if not rndom then rndom := true;
  572.                     1 : if rndom then rndom := false;
  573.                  end;
  574.                  end;
  575.              1 : begin
  576.                  case SubItemNumber of
  577.                     0 : if not needles then needles := true;
  578.                     1 : if needles then needles := false;
  579.                  end;
  580.                  end;
  581.           end;
  582.           end;
  583.     end;
  584.     end;
  585.  
  586. begin
  587.     IPtr := pIntuiMessage(Msg);
  588.     IMessage := IPtr^;
  589.     ReplyMsg(Msg);
  590.  
  591.     case IMessage.IClass of
  592.       IDCMP_MENUPICK    : ProcessMenu;
  593.       IDCMP_NEWSIZE     : refresh;
  594.       IDCMP_CLOSEWINDOW : QuitStopDie := True;
  595.     end;
  596. end;
  597.  
  598.  
  599.  
  600. begin
  601.    OpenEverything;
  602.    QuitStopDie := False;
  603.    modus := 0;
  604.    needles := true;
  605.    rndom := true;
  606.    refresh;
  607.    repeat
  608.    Msg := WaitPort(w^.UserPort);
  609.    Msg := GetMsg(w^.UserPort);
  610.        ProcessIDCMP;
  611.    until QuitStopDie;
  612.    CleanUp('',0);
  613. end.
  614.  
  615.  
  616.  
  617.